home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Dr. Windows 3
/
dr win3.zip
/
dr win3
/
UTILITY1
/
MSWLGO35.ZIP
/
EXAMPLES
/
SOLITAIR
< prev
next >
Wrap
Text File
|
1993-04-12
|
10KB
|
537 lines
;
; Function:
;
; Solitair game
;
; To Run:
;
; Load "solitair
; Call SOLITAIRE
;
;;; Every * has an INT to get around a Mac Berkeley Logo bug!
TO ASKDIGIT
MAKE "ONTO LIST "PLAYONTO :CHAR
END
TO ASKPARSE :CHAR
IF EQUALP :CHAR "U [ASKU STOP]
IF MEMBERP LIST "PLAYONTO :CHAR :ONTO [ASKDIGIT STOP]
BELL
ASKPARSE RC
END
TO ASKSTACKS :LIST
IF EMPTYP :LIST [TYPE [FOR STACK] STOP]
IF EQUALP FIRST FIRST :LIST "PLAYTOP [ASKUP STOP]
SPBTYPE 0 LAST FIRST :LIST
TYPE "| |
ASKSTACKS BF :LIST
END
TO ASKU
IFELSE EQUALP FIRST LAST :ONTO "PLAYTOP ~
[MAKE "ONTO LAST :ONTO] [BELL ASKPARSE RC]
END
TO ASKUP
TYPE [FOR STACK,]
SETCURSOR [4 21]
TYPE "OR
SPBTYPE 1 "U
TYPE [| FOR| UP.]
END
TO ASKWHICH
SETCURSOR [1 20]
TYPE [PLAY WHERE? |TYPE |]
ASKSTACKS :ONTO
ASKPARSE RC
SETCURSOR [1 20]
SPACES 37 PR []
SPACES 37 PR []
END
TO BELL
TONE 1500 6
SETEMPTY "DIGIT
END
TO BLACKTYPE :WORD
TYPE STANDOUT :WORD
END
TO CARDBEFOREP :A :B
IF EQUALP :A "A [OUTPUT EQUALP :B 2]
IF EQUALP :A 10 [OUTPUT EQUALP :B "J]
IF EQUALP :A "J [OUTPUT EQUALP :B "Q]
IF EQUALP :A "Q [OUTPUT EQUALP :B "K]
IF EQUALP :A "K [OUTPUT "FALSE]
IF NOT NUMBERP :B [OUTPUT "FALSE]
OUTPUT EQUALP :A :B-1
END
TO CARDDIS :CARD
IFELSE MEMBERP SUIT :CARD :REDS [REDTYPE :CARD] [BLACKTYPE :CARD]
TYPE "| |
END
TO CHEAT
SETCURSOR [1 22] SPACES 3
IF NOT EQUALP :DIGIT 8 [BELL STOP]
IF AND EMPTYP :HAND EMPTYP :PILE [BELL STOP]
LPUSH DEAL "PILE
DISPILE
DISHAND
SETEMPTY "DIGIT
END
TO CHECKBLACK :NUM
IF NOT MEMBERP SUIT FIRST :STACK :REDS [STOP]
IF CARDBEFOREP (RANK :CARD) (RANK FIRST :STACK) ~
[PUSH (LIST "PLAYONTO :NUM) "ONTO]
END
TO CHECKEMPTY :NUM
IF EQUALP RANK :CARD "K [PUSH (LIST "PLAYONTO :NUM) "ONTO OUTPUT "TRUE]
OUTPUT "FALSE
END
TO CHECKFULL :NUM :STACK
IFELSE MEMBERP SUIT :CARD :REDS [CHECKRED :NUM] [CHECKBLACK :NUM]
END
TO CHECKONTO :NUM
IF :NUM = 0 [STOP]
IFELSE STACKEMPTYP SHOWN :NUM ~
[IF CHECKEMPTY :NUM [STOP]] [CHECKFULL :NUM THING SHOWN :NUM]
CHECKONTO :NUM-1
END
TO CHECKRED :NUM
IF MEMBERP SUIT FIRST :STACK :REDS [STOP]
IF CARDBEFOREP (RANK :CARD) (RANK FIRST :STACK) ~
[PUSH (LIST "PLAYONTO :NUM) "ONTO]
END
TO CHECKTOP
IF EQUALP RANK :CARD "A ~
[IF EMPTYP TOP SUIT :CARD ~
[PUSH (LIST "PLAYTOP WORD "" SUIT :CARD) "ONTO] ~
STOP]
IF CARDBEFOREP (TOP SUIT :CARD) (RANK :CARD) ~
[PUSH (LIST "PLAYTOP WORD "" SUIT :CARD) "ONTO]
END
TO COVEREDP
IF EQUALP :WHERE [REMPILE] [OUTPUT "FALSE]
OUTPUT NOT EQUALP :CARD FIRST THING SHOWN LAST :WHERE
END
TO DEAL
IF EMPTYP :HAND [MAKE "HAND :PILE SETEMPTY "PILE]
IF EMPTYP :HAND [OUTPUT []]
OUTPUT SPOP "HAND
END
TO DECK
OP MAKESUITS (SE :HEART :SPADE :DIAMOND :CLUB)
END
TO DISHAND
SETCURSOR [27 23]
TYPE COUNT :HAND
TYPE "| |
END
TO DISPILE
SETCURSOR [32 23]
IFELSE EMPTYP :PILE [SPACES 3] [CARDDIS LAST :PILE]
END
TO DISSTACK :NUM
SETCURSOR LIST INT (-3+5*:NUM) 4
TYPE IFELSE STACKEMPTYP HIDDEN :NUM ["| |] ["-]
IF STACKEMPTYP SHOWN :NUM ~
[SETCURSOR LIST INT (-4+5*:NUM) 5 SPACES 3 STOP]
DISSTACK1 :NUM (THING SHOWN :NUM)
END
TO DISSTACK1 :NUM :STACK
DISSTACK2 (4+COUNT :STACK) INT (-4+5*:NUM) :STACK
END
TO DISSTACK2 :ROW :COL :STACK
IF EMPTYP :STACK [STOP]
SETCURSOR LIST :COL :ROW
CARDDIS FIRST :STACK
DISSTACK2 :ROW-1 :COL BF :STACK
END
TO DISSTACKS :NUM
IF :NUM = 0 [STOP]
DISSTACK :NUM
DISSTACKS :NUM-1
END
TO DISTOP :SUIT
IF EMPTYP TOP :SUIT [STOP]
IF EQUALP :SUIT :HEART [DISTOP1 4 STOP]
IF EQUALP :SUIT :SPADE [DISTOP1 11 STOP]
IF EQUALP :SUIT :DIAMOND [DISTOP1 18 STOP]
DISTOP1 25
END
TO DISTOP1 :COL
SETCURSOR LIST :COL 2
CARDDIS WORD (TOP :SUIT) :SUIT
END
TO FINDCARD
IF FINDPILE [STOP]
MAKE "WHERE FINDSHOWN 7
IF EMPTYP :WHERE [BELL]
END
TO FINDPILE
IF EMPTYP :PILE [OUTPUT "FALSE]
IF EQUALP :CARD LAST :PILE [MAKE "WHERE [REMPILE] OUTPUT "TRUE]
OUTPUT "FALSE
END
TO FINDSHOWN :NUM
IF :NUM = 0 [OUTPUT []]
IF MEMBERP :CARD THING SHOWN :NUM [OP SE "REMSHOWN :NUM]
OP FINDSHOWN :NUM-1
END
TO HAND3
IF NOT EMPTYP :DIGIT [BELL STOP]
IF AND EMPTYP :HAND EMPTYP :PILE [BELL STOP]
LPUSH DEAL "PILE
REPEAT 2 [IF NOT EMPTYP :HAND [LPUSH DEAL "PILE]]
DISPILE
DISHAND
END
TO SHELP
CT
INSTRUCT
SPBPR 0 [TYPE ANY KEY TO CONTINUE]
IGNORE RC
REDISPLAY
END
TO HIDDEN :NUM
OUTPUT WORD "HIDDEN :NUM
END
TO INITHIDDEN :NUM
SETEMPTY HIDDEN :NUM
REPEAT :NUM [PUSH DEAL HIDDEN :NUM]
END
TO INITSTACKS :NUM
IF :NUM = 0 [STOP]
INITHIDDEN :NUM
TURNUP :NUM
INITSTACKS :NUM-1
END
TO INSTRUCT
PR [WELCOME TO SOLITAIRE]
PR []
PR [HERE ARE THE COMMANDS YOU CAN TYPE:]
SPBTYPE 4 "+ SPPR 4 [DEAL THREE CARDS ONTO PILE]
SPBTYPE 4 "P SPPR 4 [PLAY TOP CARD FROM PILE]
SPBTYPE 4 "R SPPR 4 [REDISPLAY THE BOARD]
SPBTYPE 4 "? SPPR 4 [RETYPE THESE INSTRUCTIONS]
SPBTYPE 4 "CARD SPPR 1 [PLAY THAT CARD]
PR []
PR [A CARD CONSISTS OF A RANK:]
SPBPR 3 [A 2 3 4 5 6 7 8 9 10 J Q K]
PR [FOLLOWED BY A SUIT:]
SPBPR 3 [H S D C]
PR []
PR [IF YOU MAKE A MISTAKE,]
SPPR 3 [HIT THE SPACE BAR.]
PR []
PR [TO MOVE AN ENTIRE STACK,]
SPPR 3 [HIT THE SHIFTED STACK NUMBER:]
SPBTYPE 5 [! @ # $ % ^ &] SPPR 1 [FOR STACKS]
SPPR 5 [1 2 3 4 5 6 7]
PR []
END
TO INVTYPE :TEXT
TYPE STANDOUT :TEXT
END
TO LOOP
IF EMPTYP :DIGIT [SETCURSOR [1 22] SPACES 6 SETCURSOR [1 22]]
PARSEKEY RC
LOOP
END
TO LPOP :STACK
LOCAL "RESULT
MAKE "RESULT LAST THING :STACK
MAKE :STACK BL THING :STACK
OUTPUT :RESULT
END
TO LPUSH :THING :STACK
MAKE :STACK LPUT :THING THING :STACK
END
TO MAKESUIT :SUIT :CARDS
IF EMPTYP :CARDS [OUTPUT []]
OUTPUT FPUT (WORD FIRST :CARDS :SUIT) MAKESUIT :SUIT BF :CARDS
END
TO MAKESUITS :LIST
IF EMPTYP :LIST [OUTPUT []]
OUTPUT SE MAKESUIT FIRST :LIST [A 2 3 4 5 6 7 8 9 10 J Q K] ~
MAKESUITS BF :LIST
END
TO PARSEDIGIT :CHAR
IF NOT EMPTYP :DIGIT [BELL STOP]
MAKE "DIGIT :CHAR
TYPE :CHAR
END
TO PARSEKEY :CHAR
IF MEMBERP :CHAR [1 2 3 4 5 6 7 8 9 A J Q K] [PARSEDIGIT :CHAR STOP]
IF EQUALP :CHAR "0 [PARSEZERO STOP]
IF MEMBERP :CHAR [H S D C] [PARSESUIT :CHAR STOP]
IF MEMBERP :CHAR [+ =] [HAND3 STOP]
IF EQUALP :CHAR "R [REDISPLAY STOP]
IF EQUALP :CHAR "? [SHELP STOP]
IF EQUALP :CHAR "P [PLAYPILE STOP]
IF MEMBERP :CHAR [! @ # $ % ^ &] [PLAYSTACK :CHAR [! @ # $ % ^ &] STOP]
IF EQUALP :CHAR "| | [RUBOUT STOP]
IF EQUALP :CHAR "\( [CHEAT STOP]
BELL
END
TO PARSESUIT :CHAR
IF EMPTYP :DIGIT [BELL STOP]
IF EQUALP :DIGIT 1 [MAKE "DIGIT "A]
IF EQUALP :CHAR "H [MAKE "CHAR :HEART]
IF EQUALP :CHAR "S [MAKE "CHAR :SPADE]
IF EQUALP :CHAR "D [MAKE "CHAR :DIAMOND]
IF EQUALP :CHAR "C [MAKE "CHAR :CLUB]
TYPE :CHAR
MAKE "CARD WORD :DIGIT :CHAR
SETEMPTY "DIGIT
FINDCARD
IF NOT EMPTYP :WHERE [PLAYCARD]
END
TO PARSEZERO
IF NOT EQUALP :DIGIT 1 [BELL STOP]
MAKE "DIGIT 10
TYPE 0
END
TO PLAYCARD
SETEMPTY "ONTO
IF NOT COVEREDP [CHECKTOP]
CHECKONTO 7
IF EMPTYP :ONTO [BELL STOP]
IFELSE (COUNT :ONTO) > 1 [ASKWHICH] [MAKE "ONTO FIRST :ONTO]
RUN :WHERE
RUN :ONTO
SETEMPTY "DIGIT
END
TO PLAYONTO :NUM
IF EMPTYP :CARDS [DISSTACK :NUM STOP]
PUSH (SPOP "CARDS) SHOWN :NUM
PLAYONTO :NUM
END
TO PLAYPILE
IF EMPTYP :PILE [BELL STOP]
IF NOT EMPTYP :DIGIT [BELL STOP]
MAKE "CARD LAST :PILE
MAKE "WHERE [REMPILE]
CARDDIS :CARD
PLAYCARD
END
TO PLAYSTACK :WHICH :LIST
IF NOT EMPTYP :DIGIT [BELL STOP]
PLAYSTACK1 :WHICH :LIST 1
END
TO PLAYSTACK1 :WHICH :LIST :NUM
IF EQUALP :WHICH FIRST :LIST [PLAYSTACK2 :NUM STOP]
PLAYSTACK1 :WHICH BF :LIST :NUM+1
END
TO PLAYSTACK2 :NUM
IF STACKEMPTYP SHOWN :NUM [BELL STOP]
MAKE "CARD LAST THING SHOWN :NUM
MAKE "WHERE SE "REMSHOWN :NUM
CARDDIS :CARD
PLAYCARD
END
TO PLAYTOP :SUIT
SETTOP :SUIT RANK :CARD
DISTOP :SUIT
END
TO PUSH :THING :STACK
MAKE :STACK FPUT :THING THING :STACK
END
TO RANK :CARD
OUTPUT BL :CARD
END
TO REDISPLAY
CT
DISSTACKS 7
DISTOP :HEART
DISTOP :SPADE
DISTOP :DIAMOND
DISTOP :CLUB
DISPILE
DISHAND
SETCURSOR [1 22]
SETEMPTY "DIGIT
END
TO REDTYPE :WORD
TYPE :WORD
END
TO REMOVE :NUM :LIST
IF :NUM = 1 [OUTPUT BF :LIST]
OP FPUT FIRST :LIST REMOVE :NUM-1 BF :LIST
END
TO